home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / lib / tex / textyl / textyl.shar6.Z / textyl.shar6
Encoding:
Text File  |  1987-08-10  |  59.6 KB  |  2,187 lines
  1. #!/bin/sh
  2. # to extract, remove the header and type "sh filename"
  3. if `test ! -d ./src`
  4. then
  5.   mkdir ./src
  6.   echo "mkdir ./src"
  7. fi
  8. if `test ! -s ./src/textyl.pas.aa`
  9. then
  10. echo "writing ./src/textyl.pas.aa"
  11. cat > ./src/textyl.pas.aa << 'E_O_F'
  12.  
  13. (*$b0*)
  14.  
  15. program tyldvidvi(input,output);
  16. (* ----------------------------------------------------------
  17.         TeXtyl  line-drawing interface for TeX.
  18.           copyright (c) 1987 John S. Renner 
  19.               All rights reserved.
  20.         
  21. ABSTRACT: TeXtyl reads in a DVI file, and processes 'specials'
  22.         that refer to graphics capabilities that it knows about,
  23.         like line, spline, ThickThinSpline, and musical 
  24.         beams and slurs. TeXtyl then outputs a new DVI file, 
  25.         with the special-macros expanded and converted to 
  26.         DVI-commands for character setting.
  27.         
  28. DEPENDENCIES:  Few assumptions about Pascal are assumed. All
  29.         identifiers are unique to eight characters. There are
  30.         notes to indicate system-dependencies.
  31.         I assume the standard definition of "READ(fil, x)" to be
  32.         equivalent to "x := fil^; GET(fil)" , and
  33.         "WRITE(fil, x)" == "fil^ := x; PUT(fil)" .
  34.     Arrays are passed by reference (VAR) for efficiency.
  35.         See also the "sysdependent"  procedure; 
  36.         Problem areas, or areas for expansion are marked with ###
  37.  
  38. -------------------------------------------------------------*) 
  39. (* Revision History:
  40.     Jun. 1986  v1.0   Basic version of TeXtyl
  41.     Dec. 1986  v1.1   Added adaptive subdivision for spline
  42.                 interpolation. Added Cardinal basis.
  43.     Mar. 1987  v1.2   Added F and W flags for beginfigure
  44.             to allow required and/or actual dimensions
  45.                 to interface with files output by the
  46.             DP drawing program from Carnegie-Mellon
  47.             also various fixes
  48.     Apr. 1987  v1.3   Added linestyles (dotted, dashed, dotdashed)
  49.             
  50. *)
  51.  
  52. label
  53.     666, 30; 
  54. (*=====================CONST============================*)
  55. #include "tylext.h"
  56. #include "texpaths.h"
  57.  
  58. const
  59.   TylVersion = 'This is TeXtyl, Version 1.30';
  60.             (* for dvi-commands *)
  61.   PUT1         = 133;
  62.   SET1         = 128;
  63.   PUTRULE     = 137;
  64.   NOP         = 138;
  65.   PUSH         = 141;
  66.   POP         = 142;
  67.   RIGHTLEFT     = 143;
  68.   DOWNUP     = 157;
  69.   FONTDEF     = 244;
  70.   USEFONT     = 236; 
  71.   OURFONTFLAG     = 256; (* our special 'byte' value flag *)
  72.  
  73.   USESTDAREA = 0;    (* flag to use the 'standard' area to find .tfm files *)
  74.  
  75.         (* some conversions and numbers *)
  76.   SPPERPT     = 65536;   (* scaled points per printers point *)
  77.   SPPERMM     = 186468;  (* scaled pts per millimetre *)
  78.  
  79.   RADTODEG     = 57.29577952;     (* degrees per radian *)
  80.   DEGTORAD     = 0.0174532925; (* radians per degree *)
  81.   PI         = 3.141592654;
  82.  
  83.   TWO16 =      65536;     (* 2 ^ 16 *)
  84.   TWO20 =    1048576;    (* 2 ^ 20 *)
  85.   TWO23 =    8388608;
  86.   TWO24 =   16777216;
  87.   TWO27 =  134217728;
  88.   TWO31 = 2147483647; (* 2^31 - 1 *)
  89.  
  90.   BIGREAL = 1.0e30;
  91.   MAXVECLENsp    = 262144; (*  Normal maximum length of longest
  92.                  *  vector-font character in scaled points
  93.                *)
  94.  (* Music Font dependent constants *)
  95.   DOTCHAR       = 127;   (* ascii number of char that is a dot *)
  96.   QNOTEGHUS     = 18.0;  (* MF: Global Horizontal Units for a Quarternote *)
  97.   QNOTEGVUS     = 16.0;  (* MF: Global Vertical units for a quarternote *)
  98.   GBMGHUS       = 12.0;  (* MF: horizontal units for a grace beam *)
  99.   GBMGVUS       = 9.0;
  100.  
  101.   BMSTART     = 0;  BMEND = 69;  (* indices for start/end of the beam chars *)
  102.   LOBM1       = 0;         (* indices for the regular beam chars that *)
  103.   HIBM1       = 34;         (*   are 1 quarternote long, and *)
  104.   LOBM1p5     = 35;         (*   for those that are 1.5 quarternotes long *)
  105.   HIBM1p5     = 69;
  106.   
  107.   GBMSTART     = 70; GBMEND = 105;  (* indices for the grace beams *)
  108.   LOGBMp5      = 70;            (* indices for grace beam chars that *)
  109.   HIGBMp5      = 87;        (* are 0.5 grace quarternote long, and *)
  110.   LOGBMp66     = 88;        (* 0.66 grace quarternotes long *)
  111.   HIGBMp66     = 105;
  112.  
  113.   LoVThick     = 1;        (* Bounds for Vector char thicknesses *)
  114.   HiVThick     = 13;
  115.  
  116.   SizVFontTable    = 39; (* size of the Vector Font Table *) { 3*HiVThick }
  117.   SizMFontTable    = 18;(* size of the Music Font Table *)
  118.   MAXLABELFONTS    = 5;
  119.   SizLFontTable = MAXLABELFONTS;  (* size of the Label Font Table *)
  120.  
  121.   MAXCTLPTS     = 63; (* max number of control points *)
  122.   MAXCTLPTSp3    = 66; (* max control points + 3 *)
  123.   ARRLIMIT      = 100;    (* limit for strings and other arrays *)
  124.   MAXSPLINESEGS = 480;  (* max number of spline segments *)
  125.   MAXOLEN      = 128;    (* max length of Ostring that holds bytes of dvi cmds *)
  126.   MAXTBDs       = 50;    (* max number of Fonts-to-be-Defined *)
  127.  
  128.   MAXDVISTRINGS    = 600;    (* max number of DVI Ostrings per page *)
  129.   TFMSIZE     = 8000;    (* size of TFM array to hold .tfm file info *)
  130.   
  131.           (* Numeric names for the TeXtyl primitives *)
  132.   Aline         = 1; (* should be first *)
  133.   Aspline     = 2;
  134.   Attspline     = 3;
  135.   Abeam         = 4;
  136.   Atieslur     = 5;
  137.   Aarc         = 6;
  138.   Alabel     = 7;
  139.   Afigure     = 8; (* should be last one *)
  140.  
  141.   MAXFONTS     = 60;     (* number of TeX fonts to keep track of *)
  142.   STACKSIZE     = 50;     (* size of stack for pushes and pops *)
  143.   AREALENGTH     = TYLPATHLEN;  (* see also "sysdependent" proc for this value*)
  144.  
  145.   CR     = 13;    (* numbers of certain ascii characters  *)
  146.   LF     = 10;
  147.   HT     = 9;
  148.   FF     = 12;
  149.   ERRSIGNAL     = '?';
  150.   ERRNOTBAD    = 0;
  151.   ERRBAD     = 1;
  152.   ERRREALBAD    = 2;
  153.     
  154.  
  155.   READACCESS    = 4;
  156.   WRITEACCESS    = 2;
  157.   NOPATH    = 0;
  158.   FONTPATH    = 3;
  159.  
  160.  
  161.  
  162. (*===========================TYPES=============================*)
  163. type
  164.         (* ---- Bytes ---- *)
  165.  
  166.    Inbyt     = -128 .. 127;
  167.  
  168.    OctByt     = 0 .. 256;   (* DVI commands are 0..255, but we need
  169.                               one more for an internal flag *)
  170.    bytefile = packed file of Inbyt;
  171.  
  172.         (* ---- Strings ---- *)
  173.    asciicode     = 32 .. 126; 
  174.    charstring     = packed array [1 .. ARRLIMIT] of char;
  175.    ascstring     = packed array [1 .. ARRLIMIT] of asciicode;
  176.         (* rep for character strings *)
  177.    strng     = record 
  178.                 len: 0 .. ARRLIMIT;
  179.                 str:charstring;
  180.             end;
  181.         (* rep for ascii strings *)
  182.    astrng     = record 
  183.                 len: 0 .. ARRLIMIT;
  184.                 str: ascstring;
  185.             end; 
  186.         (* byte strings *)
  187.    pOstring     = ^Ostring;
  188.    Ostring      = packed array[1 .. MAXOLEN] of OctByt;
  189.  
  190.         (* ---- PUBLIC types ---- *)
  191.    VThickness     = LoVThick .. HiVThick;
  192.    VectKind       = (VKCirc, VKVert, VKHort);
  193.    BeamKind       = (regular, grace);
  194.    SplineKind     = (BSPL, INTBSPL, CATROM, CARD);
  195.    LineStyle    = (solid, dotted, dashed, dotdash);
  196.    ScaledPts      = integer;
  197.    MusIndex       = integer;
  198.    VecIndex       = integer;
  199.  
  200.    ThickAryType        = array[0 .. MAXSPLINESEGS] of VThickness;
  201.    SplineSegments     = array[1  ..  MAXSPLINESEGS, 1 .. 2] of ScaledPts;
  202.    ControlPoints      = array [0 .. MAXCTLPTSp3, 1 .. 2] of ScaledPts;
  203.  
  204.  
  205.         (* ----- Private Types ---- *)
  206.    FontInfRec = record
  207.                   Cht, Cdp, Cwd : ScaledPts;
  208.                   Angle : real;
  209.                   end;
  210.  
  211.    pVectFontInfRec    = ^VectFontInfRec;   (* vector font info *)
  212.    VectFontInfRec    = record
  213.               vkind : VectKind;
  214.               DesSize : ScaledPts;
  215.               PenSize : ScaledPts;
  216.               psize : VThickness;
  217.               MaxVectLen : ScaledPts;
  218.               FontName : strng;
  219.               Cksum : integer;
  220.               Isdefined : boolean;
  221.               DVIFontNum: integer;
  222.               FontInfo : array [0 .. 127] of FontInfRec;
  223.               end;
  224.  
  225.    pMusFontInfRec     = ^MusFontInfRec;    (* music font info *)
  226.    MusFontInfRec      = record
  227.               DesSize : ScaledPts;
  228.               Family : integer;
  229.               FontName : strng;
  230.               Cksum : integer;
  231.               Isdefined : boolean;
  232.               DVIFontNum: integer;
  233.               Staffsize : integer;
  234.               ghu : ScaledPts;
  235.               gvu : ScaledPts;
  236.               FontInfo : array [0 .. 127] of FontInfRec;
  237.               end;
  238.  
  239.    pLabFontInfRec    = ^LabFontInfRec;  (* label fonts info *)
  240.    LabFontInfRec    = record
  241.                  DesSize : ScaledPts;
  242.                  FontName : strng;
  243.               Cksum : integer;
  244.               Isdefined : boolean;
  245.               DVIFontNum : integer;
  246.               internalnumber : integer;
  247.               spacewidth : ScaledPts;
  248.               end;
  249.  
  250.  
  251.         (* list of dvi-strings *)
  252.    dvistary     = array[1 .. MAXDVISTRINGS] of pOstring;
  253.  
  254.    DVIBuftype     = record
  255.           TotByteLen : integer;
  256.           Numstrings : integer;
  257.           curstrindex : integer;
  258.           Dstrings : dvistary;
  259.           end;
  260.  
  261.         (* representation of list of fonts that have to be defined
  262.          *    before we output the BOP of the page we
  263.          *    just scanned 
  264.          *)
  265.    ToBeDefinedRec = record
  266.                     which : char; 
  267.                     indx : integer;
  268.                     end;
  269.  
  270.    stackrec = record 
  271.           sh, sv, sw, sx, sy, sz: integer;
  272.           end;
  273.  
  274.    Stacktype     = array [0 .. STACKSIZE] of stackrec;
  275.  
  276.    Oneby4Vector        = array[1 .. 4] of real;
  277.    Fourby4Matrix    = array[1 .. 4, 1 .. 4] of real;
  278.    Oneby5Vector        = array[1 .. 5] of real;
  279.    
  280.    Primitive = Aline .. Afigure;
  281.  
  282.    pItem    = ^Item;
  283.    figptr    = ^Figure;
  284.  
  285.    Item = packed record
  286.        nextitem : pItem;
  287.        BBlx, BBby, BBrx, BBty : ScaledPts; (* Bounding box *)
  288.        itemthick : VThickness;
  289.        itemvec : VectKind;
  290.        itempatt : LineStyle;
  291.        case kind : Primitive of
  292.            Aline : (    lx1, ly1, lx2, ly2 : ScaledPts;
  293.             );
  294.            Aspline : (    spltype : SplineKind;
  295.                 sclosed : boolean;
  296.                 dosmarks : integer;
  297.                 nsplknots : integer;
  298.                 spts : ControlPoints;
  299.               );
  300.            Attspline : (    tspltype : SplineKind;
  301.                 tclosed : boolean;
  302.                 dottmarks : integer;
  303.                 nttknots : integer;
  304.                 ttpts : ControlPoints;
  305.                 ttarry : ThickAryType;
  306.                 );
  307.            Abeam : (    bx1, by1, bx2, by2 : ScaledPts;
  308.                 staf : integer;
  309.                 bkind : BeamKind;
  310.             );
  311.            Atieslur : (    ntknots : integer;
  312.                 minth, maxth : VThickness;
  313.                 tspts : ControlPoints;
  314.                );
  315.            Aarc : (        acentx, acenty : ScaledPts;
  316.                 aradius : ScaledPts;
  317.                 firstang, lastang : integer;
  318.                 narcknots : integer;
  319.                 arcpts : ControlPoints;
  320.                );
  321.            Alabel : (    labx, laby : ScaledPts;
  322.                        fontstyle : integer;
  323.                 labeltext : strng;
  324.             );
  325.            Afigure : (    figtheta : real;
  326.                 fsx, fsy : real;
  327.                 fdx, fdy : ScaledPts;
  328.                 preWid, preHt : ScaledPts;
  329.                 postWid, postHt : ScaledPts;
  330.                 depthnumber : integer;
  331.                 body : figptr;
  332.               );
  333.           end;
  334.  
  335.    
  336.    Figure = record
  337.         things : pItem;
  338.         end;
  339.  
  340.  
  341. (*==============================VARS============================*)
  342. var
  343.    (* ----- Private vars *)
  344.     catrommtx : Fourby4Matrix;    (* basis matrix for catmul-rom splines*)
  345.     bsplmtx : Fourby4Matrix;    (* basis matrix for B-splines *)
  346.     cardmtx : Fourby4Matrix;    (* Cardinal spline matrix *)
  347.     lastPoint : integer;    (* num of output points *)
  348.     intervals : integer;    (* count of spline interval we are on *)
  349.     ourxpos,            (* internal x-position on page *)
  350.     ourypos,             (* internal y-position on page *)
  351.     ourfontnum : integer;    (* internal number of TeX font currently in use*)
  352.     ourpushdepth : integer;    (* depth of internal pushes *)
  353.     origTexfont : integer;    (* number of TeX font in use before tyling *)
  354.  
  355.     GDVIBuf : DVIBuftype;    (* Global DVI buffer that contains a list of
  356.                      * dvi commands for this page. All dvi-cmds
  357.                  * parsed are put here and possibly modified
  358.                  * before being written  to the output file
  359.                  *)
  360.  
  361.     VFontTable : array [1 .. SizVFontTable] of pVectFontInfRec;
  362.     MFontTable : array [1 .. SizMFontTable] of pMusFontInfRec;
  363.     LFontTable : array [1 .. SizLFontTable] of pLabFontInfRec;
  364.     (* the font tables, and the number of fonts defined in each *)
  365.     VFontsDefd, 
  366.     MFontsDefd,
  367.     LFontsDefd : integer;
  368.  
  369.     GDVIFN : integer;           (* dvi font number currently in use *)
  370.  
  371.             (* table of fonts yet  To-Be-Defined *)
  372.     TBD : array[1 .. MAXTBDs] of  ToBeDefinedRec;
  373.     FTBDs : integer;              (* number of fonts to be defined for current page *)
  374.  
  375.     pageitems : pItem;  (* list of primitives in current use in the current
  376.                  * figure on the current page
  377.              *)
  378.  
  379.     TotBytesWritten : integer; 
  380.     ourq : integer; (* the 'q' for the postpost *)
  381.     specstart: integer;        (* the place in the DVI buffer where the
  382.                      * start of the special begins.
  383.                  * this is so that we know how far to back up
  384.                  * and over-write the old \special macro string
  385.                  * with the cmds of our 'macro-expansion'
  386.                  *)
  387.  
  388.     multifigure : integer;    (* depth of definition recursion of figures *)
  389.     didnewfonts : boolean;    (* did we define the new fonts for this page? *)
  390.     prevfont : integer;        (* to keep track of prev font before the
  391.                      * PUSH and expansion of the special
  392.                  *)
  393.  
  394.     pgfigurenum : integer;    (* figure number for this page *)
  395.     currpagenum : integer;    (* number of page we are on *)
  396.     skiptsclamp : boolean;    (* DEBUG: should we skip post-clamping ties *)
  397.     dviBBlx, dviBBrx,         (* Bounding box of figure in DVI space *)
  398.     dviBBby, dviBBty : ScaledPts;
  399.     ErrorOccurred : boolean;    (* global flag in case some error happened *)
  400.  
  401.  
  402.     thefilename, realnameoffile : charstring; (* used externally *)
  403.  
  404.   (* ----- End private vars *)
  405.  
  406.  
  407.     tfmbyte : Inbyt;
  408.  
  409.     vaxbyt : Inbyt;
  410.  
  411.     tfm: array[-100 .. TFMSIZE] of OctByt;
  412.  
  413.     xord: array [char] of asciicode;
  414.     xchr: array [0 .. 255] of char;
  415.     outname: strng;    (* name of output file *)
  416.     tfmname : strng;    (* name of a .tfm file *)
  417.     dvifname : strng;    (* name of the input dvi file *)
  418.     logfilnam: strng;    (* name of the log file *)
  419.  
  420.     dvifile: bytefile;    
  421.     tfmfile: bytefile;
  422.     outputfil: bytefile;
  423.     logfile : text;
  424.  
  425.     curfont: integer;
  426.     s : 0 .. STACKSIZE;
  427.     h, v, w, x, y, z: integer;
  428.     stack: Stacktype;
  429.  
  430.     font: array [0 .. MAXFONTS] of 
  431.         record 
  432.             num: integer;
  433.             name: astrng;
  434.             checksum: integer;
  435.             scaledsize: integer;
  436.             designsize: integer;
  437.             space: integer;
  438.             bc: integer;
  439.             ec: integer;
  440.             widths: array [0 .. 127] of ScaledPts
  441.         end;
  442.     nf : 0 .. MAXFONTS; 
  443.  
  444.     MINREAL : real;     (* a system-dependent 'constant' *)
  445.     b0, b1, b2, b3: OctByt; 
  446.     inwidth: array [0 .. 255] of integer;
  447.     tfmchecksum: integer; 
  448.     conv: real;
  449.     trueconv: real; 
  450.     numerator, 
  451.     denominator: integer;
  452.     defaultdirectory: strng;
  453.     mag, 
  454.     magfactor: real; 
  455.     maxv, maxh, maxs : integer;
  456.     maxpages, 
  457.     totalpages : integer;
  458.     resolution: real;
  459.     inpostamble : boolean;
  460.     newbackptr, 
  461.     oldbackptr : integer;    
  462.     p, k : integer;
  463.     waste : integer;
  464.         
  465.  
  466. (* ==================forward declarations============================ *)
  467.  
  468. {  These hooks assume that the parameters are filled "correctly",
  469.     and are already transformed into 4th Quadrant DVI-space    }
  470.  
  471.  
  472. procedure TylTieSlur (var KnotArray: ControlPoints; 
  473.                       numknots: integer;
  474.                       minthick, maxthick: VThickness); forward;
  475.  
  476. procedure TylThickThinSpline (thetype : SplineKind; 
  477.               isclosed : boolean;
  478.                           var KnotArray: ControlPoints; 
  479.                           var ThikThinAry: ThickAryType;
  480.                           numknots: integer;
  481.                           vec: VectKind;
  482.               patt: LineStyle;
  483.               domarks : integer); forward;
  484.  
  485. procedure TylSpline (thetype : SplineKind; 
  486.               isclosed : boolean;
  487.                       var KnotArray: ControlPoints; 
  488.               numknots: integer;
  489.                       thick: VThickness; 
  490.               vec: VectKind;
  491.               patt: LineStyle;
  492.               domarks : integer); forward;
  493.  
  494. procedure TylLine (xl, yb, xr, yt: ScaledPts; 
  495.                      thickness: VThickness; 
  496.              vec: VectKind;
  497.              patt: LineStyle); forward;
  498.  
  499. procedure TylBeam (fromx, fromy, tox, toy: ScaledPts;
  500.                  staffsize : integer; 
  501.              kind : BeamKind); forward;
  502.  
  503. procedure TylArc (radius : ScaledPts; 
  504.           centx, centy : ScaledPts;
  505.           firstangle, secondangle : integer;
  506.           thick : VThickness; 
  507.           vec : VectKind;
  508.           patt: LineStyle); forward;
  509.  
  510. procedure TylLabel (xpos, ypos : ScaledPts;
  511.             fontstyle : integer;
  512.             phrase : charstring;
  513.             phraselen : integer); forward;
  514.  
  515. (*  private procedures *)
  516. procedure definebeams (var M : pMusFontInfRec); forward;
  517. procedure definevectors (var Vec: pVectFontInfRec); forward;
  518. procedure defineNewfonts; forward;
  519. procedure doTylArc (iscircle : boolean; var apts : ControlPoints;
  520.             numknots : integer; thick : VThickness; 
  521.             vec : VectKind; patt : LineStyle); forward;
  522. procedure strcopy (src : charstring; var dest : charstring; 
  523.             len : integer); forward;
  524. procedure writestrng (s :strng; tologfile : boolean); forward;
  525. (* end private procs *)
  526.  
  527. {------------------------------------------------------}
  528. procedure jumpout;
  529. begin
  530.     goto 666; (* global label *)
  531. end; 
  532.  
  533.  
  534. (*-------------- System Dependent stuff ----------------------*)
  535. (*  the default-directory should be where the .tfm files are 
  536.  *  to be found. the string len should reflect this name.
  537.  *  Check with the local site maintainer about any necessary
  538.  *  additions to the reset and rewrite procedures for opening
  539.  *  8-bit binary files.
  540.  *)
  541.  
  542.  
  543.  
  544.  
  545.  
  546. procedure sysdependent;
  547.  begin
  548.  
  549.  
  550.     setpaths;
  551.  
  552.     defaultdirectory.str := TYLPATH;
  553.     defaultdirectory.len := TYLPATHLEN; (* AREALENGTH const should be this, too *)
  554.     writeln(TylVersion,' for Berkeley Unix');
  555.  
  556.     resolution := 300.0; (* just a number *)
  557.     MINREAL := 1.0e-20;  (* so that we avoid some underflows *)
  558.  end;
  559.  
  560. {------------------------------------------------------------}
  561. procedure complain (severity :integer);
  562. begin
  563.  writeln(logfile,'Error in fig#',pgfigurenum:0,' on page ',currpagenum:0);
  564.  case severity of
  565.    ERRNOTBAD : begin
  566.            write (ERRSIGNAL);
  567.            end;
  568.    ERRBAD : begin
  569.            write (ERRSIGNAL);
  570.                 ErrorOccurred := true;
  571.            end;
  572.    ERRREALBAD : begin
  573.              write (ERRSIGNAL,'! ');
  574.                 ErrorOccurred := true;
  575.            end;
  576.               
  577.   end; (* case *)
  578. end;
  579.  
  580. function opendvifile : boolean;
  581. begin
  582.  
  583.     strcopy (dvifname.str, thefilename, dvifname.len);
  584.     thefilename[dvifname.len + 1] := ' ';
  585.     if (testaccess (READACCESS, NOPATH)) then
  586.       begin
  587.       reset (dvifile, realnameoffile);
  588.       opendvifile := true;
  589.       end
  590.     else
  591.       begin
  592.       writestrng(dvifname, false);
  593.       writeln(' : DVI file not found/readable ');
  594.       opendvifile := false;
  595.       end;  
  596.  
  597. end;
  598.  
  599. function opentfmfile : boolean;
  600. begin
  601.  
  602.   strcopy (tfmname.str, thefilename, tfmname.len);
  603.   thefilename[tfmname.len + 1] := ' ';
  604.   if (testaccess (READACCESS, FONTPATH)) then
  605.     begin
  606.     reset(tfmfile, realnameoffile);
  607.     opentfmfile := true;
  608.     end
  609.   else
  610.     begin
  611.     writestrng(tfmname, false);
  612.     writeln(' : TFM file not fount/readable ');
  613.     opentfmfile := false;
  614.     end;
  615.  
  616. end;
  617.  
  618. procedure openoutputfile;
  619. begin
  620.  
  621.   strcopy (outname.str, thefilename, outname.len);
  622.   thefilename[outname.len + 1] := ' ';
  623.   if (testaccess (WRITEACCESS, NOPATH)) then
  624.     rewrite (outputfil, realnameoffile)
  625.   else
  626.     begin
  627.     writestrng(outname, false);
  628.     writeln(' : Output file not writable');
  629.     jumpout;
  630.     end;
  631.  
  632. end;  
  633.  
  634. procedure openlogfile;
  635. begin
  636.  
  637.   strcopy (logfilnam.str, thefilename, logfilnam.len);
  638.   thefilename[logfilnam.len + 1] := ' ';
  639.   if (testaccess (WRITEACCESS, NOPATH)) then
  640.     rewrite (logfile, realnameoffile)
  641.   else
  642.     begin
  643.     writestrng(logfilnam, false);
  644.     writeln(' : Log file not writable');
  645.     jumpout;
  646.     end;
  647.  
  648. end;
  649.  
  650.  
  651. (* &&Module Tylsupport *)
  652.  
  653.  
  654. {---------------------------------------------------}
  655. procedure ClearBufString (var s : pOstring);
  656. (* clear a DVI buffer string  to contain no-ops*)
  657. var i : integer;
  658. begin
  659.   for i := 1 to MAXOLEN do
  660.     s^[i] := NOP;
  661. end;
  662.  
  663. {---------------------------------------------------}
  664. function NewBufString : pOstring;
  665. var s : pOstring;
  666. begin
  667.  new (s);
  668.  ClearBufString (s);
  669.  NewBufString := s;
  670. end;
  671.  
  672.  
  673.  
  674. (* NOTATION::
  675.  *       All procedures that put a dvi-command into the
  676.  *  temporary buffer are prefixed with "cmd"...
  677.  *       Functions that deal with reading .tfm files are prefixed
  678.  *  with "T" or have "tfm" in their names.       
  679.  *       Functions that deal with reading DVI files are
  680.  *  prefixed with a "D". 
  681.  *)
  682.  
  683. {--------------------------------------------}
  684. procedure cmd1byte (cmd : OctByt);
  685. begin
  686.   with GDVIBuf do
  687.     begin
  688.     if (Numstrings > MAXDVISTRINGS) then (* buffer full *)
  689.       begin
  690.       complain (ERRREALBAD);
  691.       writeln (logfile,'error: too many dvistrings. Totbytes = ',TotByteLen);
  692.       jumpout;
  693.       end;
  694.     if (curstrindex > MAXOLEN) then  (* current string full *)
  695.       begin
  696.       Numstrings := Numstrings + 1;
  697.       if (Dstrings[Numstrings] <> nil) then
  698.          dispose (Dstrings[Numstrings]);
  699.       Dstrings[Numstrings] := NewBufString;
  700.       ClearBufString(Dstrings[Numstrings]);
  701.       curstrindex := 1;
  702.       end;
  703.     Dstrings[Numstrings]^[curstrindex] := cmd; (* insert command byte *)
  704.     TotByteLen := TotByteLen + 1;
  705.     curstrindex := curstrindex + 1;
  706.     end;
  707. end;
  708.       
  709.  
  710. {---------------------------------------------------}
  711. procedure cmd2byte (cmd : integer);
  712. begin
  713.   cmd1byte (cmd div 256);
  714.   cmd1byte (cmd mod 256);
  715. end;
  716.  
  717. {---------------------------------------------------}
  718. procedure cmd3byte (cmd : integer);
  719. begin
  720.   cmd1byte (cmd div TWO16);
  721.   cmd1byte ((cmd div 256) mod 256);
  722.   cmd1byte (cmd mod 256);
  723. end;  
  724.  
  725. {---------------------------------------------------}
  726. procedure cmd4byte (cmd : integer);
  727. var tmp : integer;
  728. begin
  729.   tmp := cmd;
  730.   if (tmp >= 0) then
  731.     begin
  732.     cmd1byte (tmp div TWO24);
  733.     end
  734.   else
  735.     begin
  736.     tmp := tmp + TWO31 + 1; (* need the +1 *)
  737.     cmd1byte (tmp div TWO24 + 128);
  738.     end; 
  739.   tmp := tmp mod TWO24;
  740.   cmd1byte (tmp div TWO16);
  741.   tmp := tmp mod TWO16;
  742.   cmd1byte (tmp div 256);
  743.   cmd1byte (tmp mod 256);
  744. end;
  745.  
  746. {---------------------------------------------------}
  747. (* ### may be system dependent as integers are assumed 
  748.    to be signed 32-bits *)
  749.  
  750. procedure cmdSigned (i : integer; numbytes: integer);
  751. var tmp : integer;
  752. begin
  753.   if (numbytes = 4) then
  754.     cmd4byte (i)
  755.   else
  756.     begin     (* <= 3 bytes *)
  757.     tmp := i;
  758.     if (numbytes = 3) then
  759.       begin
  760.       if (tmp < 0) then
  761.         tmp := tmp + TWO24;
  762.       cmd1byte (tmp div TWO16);
  763.       tmp := tmp mod TWO16;
  764.       cmd1byte (tmp div 256);
  765.       end;
  766.     if (numbytes = 2) then
  767.       begin
  768.       if (tmp < 0) then
  769.     tmp := tmp + TWO16;
  770.       cmd1byte (tmp div 256);
  771.       end;  
  772.     if (numbytes = 1) then
  773.       begin
  774.       if (tmp < 0) then
  775.         tmp := tmp + 256;
  776.       end;
  777.     cmd1byte (tmp mod 256); (* for all *)
  778.     end;
  779. end;
  780.  
  781.  
  782.  
  783. {---------------------------------------------------}
  784. function Tgetvaxbyte : OctByt;
  785. label 9999;
  786. begin
  787.   tfmbyte := tfmfile^;
  788.   if (tfmbyte < 0) then
  789.     Tgetvaxbyte := tfmbyte + 256
  790.   else 
  791.     Tgetvaxbyte := tfmbyte;
  792.   if (eof (tfmfile)) then
  793.     begin
  794.     complain (ERRREALBAD);
  795.     writeln (logfile,' early EOF of tfm file! ');
  796.     goto 9999;
  797.     end;
  798.   get (tfmfile);
  799. 9999:       
  800. end;
  801.  
  802.  
  803. {---------------------------------------------------}
  804. procedure readtfmword;
  805.  
  806. begin
  807.  
  808.   b0 := Tgetvaxbyte;
  809.   b1 := Tgetvaxbyte;
  810.   b2 := Tgetvaxbyte;
  811.   b3 := Tgetvaxbyte;
  812.  
  813. end; 
  814.  
  815.  
  816. {---------------------------------------------------}
  817. function DVaxByte : OctByt;
  818. label 99;
  819. begin
  820.   vaxbyt := dvifile^;
  821.   if (eof (dvifile)) then
  822.     begin
  823.     DVaxByte := 0;
  824.     goto 99;
  825.     end;
  826.   if (vaxbyt < 0) then
  827.     DVaxByte := vaxbyt + 256
  828.   else  
  829.     DVaxByte := vaxbyt;
  830.   get (dvifile);
  831. 99:     
  832. end;
  833.  
  834.  
  835.  
  836. {---------------------------------------------------}
  837. (* get a byte from the DVI file, but do not copy it into the DVIbuffer *)
  838. function Dgrabbyte : integer;
  839. var
  840.     b: OctByt;
  841. begin
  842.   if eof(dvifile) then 
  843.     Dgrabbyte := 0
  844.   else
  845.      begin
  846.  
  847.      b := DVaxByte;
  848.  
  849.      Dgrabbyte := b;
  850.      end;
  851. end;
  852.  
  853.  
  854. {---------------------------------------------------}
  855. function Dget1byte : integer;
  856. var
  857.     b: OctByt;
  858. begin
  859.     if eof(dvifile) then 
  860.     Dget1byte := 0
  861.     else
  862.      begin
  863.  
  864.      b := DVaxByte;
  865.  
  866.      Dget1byte := b
  867.     end;
  868.     cmd1byte(b);
  869. end;
  870.  
  871. {---------------------------------------------------}
  872. function Dsign1byte : integer;
  873. var
  874.     b: OctByt;
  875. begin
  876.  
  877.     b := DVaxByte;
  878.  
  879.     if b < 128 then 
  880.     Dsign1byte := b
  881.     else 
  882.     Dsign1byte := b - 256;
  883.     cmd1byte(b);
  884. end; 
  885.  
  886. {---------------------------------------------------}
  887. function Dget2byte : integer;
  888. var
  889.     a, b: OctByt;
  890. begin
  891.  
  892.     a := DVaxByte;
  893.     b := DVaxByte;
  894.  
  895.     Dget2byte := a * 256 + b;
  896.     cmd1byte(a);
  897.     cmd1byte(b);
  898. end;
  899.  
  900. {---------------------------------------------------}
  901. function Dsign2byte : integer;
  902. var
  903.     a, b: OctByt;
  904. begin
  905.  
  906.     a := DVaxByte;
  907.     b := DVaxByte;
  908.  
  909.     if a < 128 then 
  910.     Dsign2byte := a * 256 + b
  911.     else 
  912.     Dsign2byte := (a - 256) * 256 + b;
  913.     cmd1byte(a);
  914.     cmd1byte(b);
  915. end;
  916.  
  917. {---------------------------------------------------}
  918. function Dget3byte : integer;
  919. var
  920.     a, b, c: OctByt;
  921. begin
  922.  
  923.     a := DVaxByte;
  924.     b := DVaxByte;
  925.     c := DVaxByte;
  926.  
  927.     Dget3byte := (a * 256 + b) * 256 + c;
  928.     cmd1byte(a);
  929.     cmd1byte(b);
  930.     cmd1byte(c);
  931. end;
  932.  
  933. {---------------------------------------------------}
  934. function Dsign3byte : integer;
  935. var
  936.     a, b, c: OctByt;
  937. begin
  938.  
  939.     a := DVaxByte;
  940.     b := DVaxByte;
  941.     c := DVaxByte;
  942.  
  943.     if a < 128 then 
  944.     Dsign3byte := (a * 256 + b) * 256 + c
  945.     else 
  946.     Dsign3byte := ((a - 256) * 256 + b) * 256 + c;
  947.     cmd1byte(a);
  948.     cmd1byte(b);
  949.     cmd1byte(c);    
  950. end;
  951.  
  952. {---------------------------------------------------}
  953. function Dsign4byte : integer;
  954. var
  955.     a, b, c, d: OctByt;
  956. begin
  957.  
  958.     a := DVaxByte;
  959.     b := DVaxByte;
  960.     c := DVaxByte;
  961.     d := DVaxByte;
  962.  
  963.     if a < 128 then 
  964.     Dsign4byte := ((a * 256 + b) * 256 + c) * 256 + d
  965.     else 
  966.     Dsign4byte := (((a - 256) * 256 + b) * 256 + c) * 256 + d;
  967.     cmd1byte(a);
  968.     cmd1byte(b);
  969.     cmd1byte(c);
  970.     cmd1byte(d);    
  971. end;
  972.  
  973.  
  974. {---------------------------------------------------}
  975. (* write a byte out to the ouput file, but if we
  976.  * encounter the font flag, define the new fonts, and
  977.  * continue
  978.  *)
  979. procedure OutputByte (b : OctByt);
  980. var x : Inbyt;
  981.     n : integer;
  982. begin
  983.    n := b;
  984.    if (n = OURFONTFLAG) then
  985.      begin    (* our special macro-flag *)
  986.      n := NOP; (* nullify it *)
  987.      if (not didnewfonts) then
  988.        begin
  989.        didnewfonts := true;       
  990.        defineNewfonts; (* expand the defns in the outfile itself *)
  991.        end;
  992.      end;  (* if *)
  993.  
  994.     if (n > 127) then
  995.       begin
  996.       x := n - 256;
  997.       end
  998.     else
  999.       x := n;
  1000.     outputfil^ := x;
  1001.     put (outputfil);
  1002.  
  1003.   TotBytesWritten := TotBytesWritten + 1;  (* keep count of all bytes *)
  1004. end;
  1005.  
  1006. {---------------------------------------------------} 
  1007. procedure Output2Byte (i : integer);
  1008. begin
  1009.   OutputByte (i div 256);
  1010.   OutputByte (i mod 256);
  1011. end;
  1012. E_O_F
  1013. else
  1014.   echo "will not over write ./src/textyl.pas.aa"
  1015. fi
  1016. chmod 644 ./src/textyl.pas.aa
  1017. if [ `wc -c ./src/textyl.pas.aa | awk '{printf $1}'` -ne 26016 ]
  1018. then
  1019. echo `wc -c ./src/textyl.pas.aa | awk '{print "Got " $1 ", Expected " 26016}'`
  1020. fi
  1021. if `test ! -s ./src/tylext.c`
  1022. then
  1023. echo "writing ./src/tylext.c"
  1024. cat > ./src/tylext.c << 'E_O_F'
  1025. /* External procedures for dvitype                */
  1026. /*   Written by: H. Trickey, 2/19/83 (adapted from TeX's ext.c) */
  1027.  
  1028. #include "texpaths.h"    /* defines default TEXFONTS path */
  1029. #include "h00vars.h"        /* defines Pascal I/O structure */
  1030.  
  1031. char *fontpath;
  1032.  
  1033. char *getenv();
  1034.  
  1035. /*
  1036.  * setpaths is called to set up the pointer fontpath
  1037.  * as follows:  if the user's environment has a value for TEXFONTS
  1038.  * then use it;  otherwise, use defaultfontpath.
  1039.  */
  1040. setpaths()
  1041. {
  1042.     register char *envpath;
  1043.     
  1044.     if ((envpath = getenv("TEXFONTS")) != NULL)
  1045.         fontpath = envpath;
  1046.     else
  1047.         fontpath = defaultfontpath;
  1048. }
  1049.  
  1050. #define namelength 100   /* should agree with defn in textyl program*/
  1051. extern char thefilename[],realnameoffile[]; /* these have size namelength */
  1052.  
  1053. /*
  1054.  *    testaccess(amode,filepath)
  1055.  *
  1056.  *  Test whether or not the file whose name is in the global thefilename
  1057.  *  can be opened for reading (if mode=READACCESS)
  1058.  *  or writing (if mode=WRITEACCESS).
  1059.  *
  1060.  *  The filepath argument is one of the ...FILEPATH constants defined below.
  1061.  *  If the filename given in thefilename does not begin with '/', we try 
  1062.  *  prepending all the ':'-separated areanames in the appropriate path to the
  1063.  *  filename until access can be made, if it ever can.
  1064.  *
  1065.  *  The realnameoffile global array will contain the name that yielded an
  1066.  *  access success.
  1067.  */
  1068.  
  1069. #define READACCESS 4
  1070. #define WRITEACCESS 2
  1071.  
  1072. #define NOFILEPATH 0
  1073. #define FONTFILEPATH 3
  1074.  
  1075. bool
  1076. testaccess(amode,filepath)
  1077.     int amode,filepath;
  1078. {
  1079.     register    bool ok;
  1080.     register char  *p;
  1081.     char   *curpathplace;
  1082.     int     f;
  1083.  
  1084.     switch (filepath) {
  1085.     case NOFILEPATH: 
  1086.         curpathplace = NULL;
  1087.         break;
  1088.     case FONTFILEPATH: 
  1089.         curpathplace = fontpath;
  1090.         break;
  1091.     }
  1092.     if (thefilename[0] == '/')    /* file name has absolute path */
  1093.     curpathplace = NULL;
  1094.     do {
  1095.     packrealnameoffile (&curpathplace);
  1096.     if (amode == READACCESS)/* use system call "access" to see if we
  1097.                    could read it */
  1098.         if (access (realnameoffile, READACCESS) == 0)
  1099.         ok = TRUE;
  1100.         else
  1101.         ok = FALSE;
  1102.     else {
  1103.     /* WRITEACCESS: use creat to see if we could create it, but close
  1104.        the file again if we''re OK, to let pc open it for real */
  1105.         f = creat (realnameoffile, 0666);
  1106.         if (f >= 0)
  1107.         ok = TRUE;
  1108.         else
  1109.         ok = FALSE;
  1110.         if (ok)
  1111.         close (f);
  1112.     }
  1113.     } while (!ok && curpathplace != NULL);
  1114.     if (ok) {            /* pad realnameoffile with blanks, as
  1115.                    Pascal wants */
  1116.     for (p = realnameoffile; *p != '\0'; p++)
  1117.                 /* nothing: find end of string */
  1118.         ;
  1119.     while (p < &(realnameoffile[namelength]))
  1120.         *p++ = ' ';
  1121.     }
  1122.     return (ok);
  1123. }
  1124.  
  1125. /*
  1126.  * packrealnameoffile(cpp) makes realnameoffile contain the directory at *cpp,
  1127.  * followed by '/', followed by the characters in thefilename up until the
  1128.  * first blank there, and finally a '\0'.  The cpp pointer is left pointing
  1129.  * at the next directory in the path.
  1130.  * But: if *cpp == NULL, then we are supposed to use thefilename as is.
  1131.  */
  1132. packrealnameoffile(cpp)
  1133.     char **cpp;
  1134. {
  1135.     register char  *p,
  1136.                    *realname;
  1137.  
  1138.     realname = realnameoffile;
  1139.     if ((p = *cpp) != NULL) {
  1140.     while ((*p != ':') && (*p != '\0')) {
  1141.         *realname++ = *p++;
  1142.         if (realname == &(realnameoffile[namelength - 1]))
  1143.         break;
  1144.     }
  1145.     if (*p == '\0')
  1146.         *cpp = NULL;    /* at end of path now */
  1147.     else
  1148.         *cpp = p + 1;    /* else get past ':' */
  1149.     *realname++ = '/';    /* separate the area from the name to
  1150.                    follow */
  1151.     }
  1152.  /* now append thefilename to realname... */
  1153.     p = thefilename;
  1154.     while (*p != ' ') {
  1155.     if (realname >= &(realnameoffile[namelength - 1])) {
  1156.         fprintf (stderr, "! Full file name is too long\n");
  1157.         break;
  1158.     }
  1159.     *realname++ = *p++;
  1160.     }
  1161.     *realname = '\0';
  1162. }
  1163. E_O_F
  1164. else
  1165.   echo "will not over write ./src/tylext.c"
  1166. fi
  1167. chmod 644 ./src/tylext.c
  1168. if [ `wc -c ./src/tylext.c | awk '{printf $1}'` -ne 3668 ]
  1169. then
  1170. echo `wc -c ./src/tylext.c | awk '{print "Got " $1 ", Expected " 3668}'`
  1171. fi
  1172. if `test ! -s ./src/textyl.pas.ad`
  1173. then
  1174. echo "writing ./src/textyl.pas.ad"
  1175. cat > ./src/textyl.pas.ad << 'E_O_F'
  1176.  * given unit-radius. Scale those points to fit the desired radius
  1177.  *)
  1178. procedure defineCircleCpts (rad : ScaledPts; centx, centy : ScaledPts;
  1179.                 var CircleCpt : ControlPoints;
  1180.                 var numpts : integer);
  1181. const UnitRadius = 16777216; (* TWO24 scaledpts *)
  1182. var ratio : real;
  1183. begin
  1184.   if (rad = 0) then
  1185.     begin
  1186.     complain (ERRBAD);
  1187.     writeln(logfile,'Error in fig#',pgfigurenum:0,' on page ',currpagenum:0);
  1188.     writeln(logfile,'Zero length radius for circle! Setting to 1 sp');
  1189.     rad := 1;
  1190.     end;
  1191.   ratio := float(rad) / float(UnitRadius);
  1192.   numpts := 16;
  1193.   CircleCpt[1,1] := round (ratio * 16777216.00000) + centx;
  1194.   CircleCpt[1,2] := 0 + centy; {round (ratio *      0.00000)}
  1195.   CircleCpt[2,1] := round (ratio * 15500126.47492) + centx;
  1196.   CircleCpt[2,2] := round (ratio * 6420362.60441) + centy;
  1197.   CircleCpt[3,1] := round (ratio * 11863283.20303) + centx;
  1198.   CircleCpt[3,2] := round (ratio * 11863283.20303) + centy;
  1199.   CircleCpt[4,1] := round (ratio * 6420362.60441) + centx;
  1200.   CircleCpt[4,2] := round (ratio * 15500126.47492) + centy;
  1201.   CircleCpt[5,1] := 0 + centx; {round (ratio *     -0.00000) }
  1202.   CircleCpt[5,2] := round (ratio * 16777216.00000) + centy;
  1203.   CircleCpt[6,1] := round (ratio * -6420362.60441) + centx;
  1204.   CircleCpt[6,2] := round (ratio * 15500126.47492) + centy;
  1205.   CircleCpt[7,1] := round (ratio * -11863283.20303) + centx;
  1206.   CircleCpt[7,2] := round (ratio * 11863283.20303) + centy;
  1207.   CircleCpt[8,1] := round (ratio * -15500126.47492) + centx;
  1208.   CircleCpt[8,2] := round (ratio * 6420362.60441) + centy;
  1209.   CircleCpt[9,1] := round (ratio * -16777216.00000) + centx;
  1210.   CircleCpt[9,2] := 0 + centy; {round (ratio *     -0.00000)}
  1211.   CircleCpt[10,1] := round (ratio * -15500126.47492) + centx;
  1212.   CircleCpt[10,2] := round (ratio * -6420362.60441) + centy;
  1213.   CircleCpt[11,1] := round (ratio * -11863283.20303) + centx;
  1214.   CircleCpt[11,2] := round (ratio * -11863283.20303) + centy;
  1215.   CircleCpt[12,1] := round (ratio * -6420362.60441) + centx;
  1216.   CircleCpt[12,2] := round (ratio * -15500126.47492) + centy;
  1217.   CircleCpt[13,1] := 0 + centx; {round (ratio *      0.00000) }
  1218.   CircleCpt[13,2] := round (ratio * -16777216.00000) + centy;
  1219.   CircleCpt[14,1] := round (ratio * 6420362.60441) + centx;
  1220.   CircleCpt[14,2] := round (ratio * -15500126.47492) + centy;
  1221.   CircleCpt[15,1] := round (ratio * 11863283.20303) + centx;
  1222.   CircleCpt[15,2] := round (ratio * -11863283.20303) + centy;
  1223.   CircleCpt[16,1] := round (ratio * 15500126.47492) + centx;
  1224.   CircleCpt[16,2] := round (ratio * -6420362.60441) + centy;
  1225.  (*   create the pre-list phantom *)
  1226.   CircleCpt[0,1] := CircleCpt[16,1];
  1227.   CircleCpt[0,2] := CircleCpt[16,2];  
  1228. end;
  1229.  
  1230.  
  1231. {---------------------------------------------------------------}
  1232. (* compute control points for an arc going from startangle to 
  1233.  * stopangle, centered at (centx, centy)
  1234.  *)
  1235. procedure definearcpts (rad : ScaledPts; centx, centy : ScaledPts;
  1236.             startang, stopang : integer;
  1237.             var cpts : ControlPoints;
  1238.             var nknots : integer);
  1239. var n : integer;
  1240.     a, b, curr, delta: real;
  1241.     i : integer;
  1242. begin
  1243.   a := startang * DEGTORAD;
  1244.   b := stopang * DEGTORAD;
  1245.   n := 16;
  1246.  
  1247.   if (a > b) then
  1248.    begin
  1249.     a := a - (2 * PI);
  1250.    end;
  1251.  
  1252.   delta := abs(b - a) / n;
  1253.  
  1254.   if (a = b) then
  1255.    begin
  1256.    complain (ERRNOTBAD);
  1257.    writeln(logfile,'Error in compute arc points:: should be a circle');
  1258.    end;
  1259.  curr := a;
  1260.  i := 1;
  1261.  while ((curr <= b)) do
  1262.    begin     (* make arc about (centx,centy) *)
  1263.    cpts[i,1] := round (rad * cos (curr)) + centx;
  1264.    cpts[i,2] := round (rad * sin (curr)) + centy;
  1265.    i := i + 1;
  1266.    curr := curr + delta;
  1267.    end;  (* while *)
  1268.  
  1269. (* go one point beyond --
  1270.  *  around the arc so that we can have good smoothness
  1271.  *  for this phantom point 
  1272.  *)
  1273.  
  1274.  cpts[i,1] := round (rad * cos (b + delta)) + centx;
  1275.  cpts[i,2] := round (rad * sin (b + delta)) + centy;
  1276.  
  1277. (* and one phantom point before the list *)
  1278.  cpts[0,1] := round (rad * cos (a - delta)) + centx;
  1279.  cpts[0,2] := round (rad * sin (a - delta)) + centy;
  1280.  
  1281.  
  1282.  nknots := i-1;
  1283. end; 
  1284.               
  1285.   
  1286.  
  1287. (* &&Module spline.p *)
  1288. (*
  1289.  Procedures below may make free use of the global variables
  1290.         arrayXY   [list of control points]
  1291.         pointmatrix [list of spline segments]
  1292.         knot    [list of spline knots]
  1293.         catrommtx  [matrix for Catmull-Rom splines]
  1294.         bsplmtx   [matrix for B-splines]
  1295.         lastPoint, intervals
  1296. *)
  1297.  
  1298.  
  1299. {-----------------------------------------------------}
  1300. function max (a, b: integer):integer;
  1301. begin
  1302.   if (a > b) then
  1303.     max := a
  1304.   else
  1305.     max := b;
  1306. end;
  1307.  
  1308. {-----------------------------------------------------}
  1309. function min (a, b: integer):integer;
  1310. begin
  1311.   if (a < b) then
  1312.     min := a
  1313.   else
  1314.     min := b;
  1315. end;
  1316.  
  1317. {---------------------------------------------------------------------}
  1318. (* initialize the Catmull-Rom basis matrix *)
  1319.  
  1320. procedure initcrmatrix;
  1321. begin
  1322.   catrommtx[1,1] := -0.5; catrommtx[1,2] := 1.5;
  1323.   catrommtx[1,3] := -1.5; catrommtx[1,4] := 0.5;
  1324.   catrommtx[2,1] := 1.0;  catrommtx[2,2] := -2.5;
  1325.   catrommtx[2,3] := 2.0;  catrommtx[2,4] := -0.5;
  1326.   catrommtx[3,1] := -0.5; catrommtx[3,2] := 0.0;
  1327.   catrommtx[3,3] := 0.5;  catrommtx[3,4] := 0.0;
  1328.   catrommtx[4,1] := 0.0;  catrommtx[4,2] := 1.0;
  1329.   catrommtx[4,3] := 0.0;  catrommtx[4,4] := 0.0;
  1330. end;
  1331.  
  1332. {-----------------------------------------------------}
  1333. procedure initbsplmatrix;
  1334. begin
  1335.   bsplmtx[1,1] := -1.0/6.0;     bsplmtx[1,2] := 0.5;
  1336.   bsplmtx[1,3] := -0.5;         bsplmtx[1,4] := 1.0/6.0;
  1337.   bsplmtx[2,1] := 0.5;          bsplmtx[2,2] := -1.0;
  1338.   bsplmtx[2,3] := 0.5;          bsplmtx[2,4] := 0.0;
  1339.   bsplmtx[3,1] := -0.5;         bsplmtx[3,2] := 0.0;
  1340.   bsplmtx[3,3] := 0.5;          bsplmtx[3,4] := 0.0;
  1341.   bsplmtx[4,1] := 1.0/6.0;      bsplmtx[4,2] := 2.0/3.0;
  1342.   bsplmtx[4,3] := 1.0/6.0;      bsplmtx[4,4] := 0.0;
  1343. end;
  1344.  
  1345. {--------------------------------------------------------}    
  1346. (* init the Cardinal Spline Matrix *)
  1347. procedure initcardmatrix;
  1348. begin
  1349.   cardmtx[1,1] := -1.0; cardmtx[1,2] := 1.0;
  1350.   cardmtx[1,3] := -1.0; cardmtx[1,4] := 1.0;
  1351.   cardmtx[2,1] := 2.0;  cardmtx[2,2] := -2.0;
  1352.   cardmtx[2,3] := 1.0;  cardmtx[2,4] := -1.0;
  1353.   cardmtx[3,1] := -1.0; cardmtx[3,2] := 0.0;
  1354.   cardmtx[3,3] := 1.0;  cardmtx[3,4] := 0.0;
  1355.   cardmtx[4,1] := 0.0;  cardmtx[4,2] := 1.0;
  1356.   cardmtx[4,3] := 0.0;  cardmtx[4,4] := 0.0;
  1357. end;
  1358.  
  1359. {--------------------------------------------------------}    
  1360. procedure initallspline;
  1361.   begin
  1362.   initcrmatrix;
  1363.   initbsplmatrix;
  1364.   initcardmatrix;
  1365.   end;
  1366.  
  1367.  
  1368. {-----------------------------------------------------}
  1369. procedure matXvector (var m: Fourby4Matrix; (* IN *)
  1370.             var v: Oneby4Vector; (* IN *)
  1371.                         var result: Oneby4Vector); (* OUT *)
  1372. var t: Oneby4Vector;
  1373. begin
  1374.   t[1] := v[1]*m[1,1] + v[2]*m[1,2] + v[3]*m[1,3] + v[4]*m[1,4];
  1375.   t[2] := v[1]*m[2,1] + v[2]*m[2,2] + v[3]*m[2,3] + v[4]*m[2,4];
  1376.   t[3] := v[1]*m[3,1] + v[2]*m[3,2] + v[3]*m[3,3] + v[4]*m[3,4];
  1377.   t[4] := v[1]*m[4,1] + v[2]*m[4,2] + v[3]*m[4,3] + v[4]*m[4,4];
  1378.   result[1] := t[1]; result[2] := t[2];
  1379.   result[3] := t[3]; result[4] := t[4];
  1380. end;
  1381.  
  1382. {-----------------------------------------------------}
  1383. (* actually the dot-product *)
  1384. function vecXvec (var v1, v2: Oneby4Vector) : real;
  1385. begin
  1386.   vecXvec := v1[1]*v2[1] + v1[2]*v2[2] + v1[3]*v2[3] + v1[4]*v2[4];
  1387. end;
  1388.  
  1389.  
  1390. {------------------------------------------------------}
  1391. (* basXctl is the pre-computed BasisMatrix times the control-point vector *)
  1392.  
  1393. function splinePosition (var basXctl : Oneby4Vector; (* IN *)
  1394.             t : real ) : real;
  1395. var tvect : Oneby4Vector;    { vector of t values for spline matrix}
  1396. begin
  1397.   tvect[4] := 1.0;
  1398.   tvect[3] := t;
  1399.   tvect[2] := t * t;
  1400.   if (tvect[2] <= MINREAL) then
  1401.     begin            (* avoid underflow problems *)
  1402.     tvect[2] := 0.0;
  1403.     end;
  1404.   tvect[1] := t * tvect[2];  (* t^3 *)
  1405.   splinePosition := vecXvec (tvect, basXctl);  
  1406. end;  
  1407.             
  1408. {-------------------------------------------------}
  1409. function TwoToThe (n : integer) : integer;
  1410. label 78;
  1411. var i : integer;
  1412.     tmp : integer;
  1413. begin
  1414. tmp := 1;
  1415. if (n <= 0) then
  1416.   goto 78;
  1417. if (n < 6) then
  1418.   begin
  1419.     case n of
  1420.       1 : tmp := 2;
  1421.       2 : tmp := 4;
  1422.       3 : tmp := 8;
  1423.       4 : tmp := 16;
  1424.       5 : tmp := 32;
  1425.     end; (* case *)
  1426.   end  (* if *)
  1427. else
  1428.   begin
  1429.   tmp := 32;
  1430.   for i := 6 to n do
  1431.    tmp := tmp * 2;
  1432.   end;
  1433. 78:
  1434.   TwoToThe := tmp;
  1435. end;  
  1436.  
  1437. {------------------------------------------------------}
  1438. function distance (x0, y0, x1, y1 : real) : real;
  1439. var res : real;
  1440. begin
  1441.   res := sqrt ( (x1 - x0)*(x1 - x0) + (y1 - y0)*(y1 - y0));
  1442.   distance := res;
  1443. end;  
  1444.  
  1445.  
  1446. {------------------------------------------------------}
  1447. (* compute the number of subdivisions for this span.
  1448.    We do this by a quadrature method and a simple linear-distance
  1449.    metric. This is not optimal in the number of subdivisions actually
  1450.    required, but is computationally efficient and accurate to the 
  1451.    nearest power of 2 .
  1452.    *)
  1453. function numsubdivisions (var XtimesBas, YtimesBas : Oneby4Vector;
  1454.               resolution : ScaledPts): integer;
  1455. var n : integer;
  1456.     d : integer;  
  1457.     t : real;
  1458.     x0, y0, xt, yt : real;
  1459. begin
  1460.   x0 := splinePosition (XtimesBas, 0.0);
  1461.   y0 := splinePosition (YtimesBas, 0.0);
  1462.  
  1463.   t := 1.0;
  1464.   n := 0;
  1465.   xt := splinePosition (XtimesBas, t);
  1466.   yt := splinePosition (YtimesBas, t);  
  1467.  
  1468.   while ((round (distance (x0, y0, xt, yt)) > resolution) or
  1469.        (n < 1)) do
  1470.     begin
  1471.     t := t / 2.0; (* perform the quadrature *)
  1472.     n := n + 1;
  1473.     xt := splinePosition (XtimesBas, t);
  1474.     yt := splinePosition (YtimesBas, t);  
  1475.     end;  (* while *)
  1476.   numsubdivisions := TwoToThe (n);  
  1477. end;  
  1478.  
  1479. {------------------------------------------------------------------------}
  1480. (*  compute new control vertices such that the resulting spline
  1481.  * will interpolate through the old control points.
  1482.  * This will work as long as the actual arc length
  1483.  * between consecutive nodes does not vary from span to span.
  1484.  * The method is noted in Wu and Abel's CACM 20(10) Oct 77 paper 
  1485.  * but the actual working method is from
  1486.  *    Barsky and Greenberg's paper in
  1487.  *    CG&IP 14(3) Nov 1980 pp.203-226
  1488.  *)
  1489. procedure invertsplvertices (numpts : integer; 
  1490.                 isclosed : boolean;
  1491.                 var xys : ControlPoints); (* INOUT *)
  1492. var i : integer;
  1493.     beta, Xrprime, Yrprime : array[0..MAXCTLPTS] of real;
  1494.     tempxys : ControlPoints;
  1495. begin
  1496.     (* compute the values of beta *)
  1497.   beta[1] := 0.25;
  1498.   for i := 2 to numpts + 1 do
  1499.     beta[i] := 1.0 / (4.0 - beta[i - 1]);
  1500.  
  1501.     (* and the r primes from the original vertices *)
  1502.   Xrprime[1] := beta[1] * xys[1,1] * 5.0;
  1503.   Yrprime[1] := beta[1] * xys[1,2] * 5.0;
  1504.   for i := 2 to numpts -1 do
  1505.     begin
  1506.     Xrprime[i] := beta[i] * (6.0 * xys[i,1] - Xrprime[i - 1]);
  1507.     Yrprime[i] := beta[i] * (6.0 * xys[i,2] - Yrprime[i - 1]);
  1508.     end;  (* for *)
  1509.   Xrprime[numpts] := beta[numpts] * (5.0 * xys[numpts,1] - Xrprime[numpts - 1]);
  1510.   Yrprime[numpts] := beta[numpts] * (5.0 * xys[numpts,2] - Yrprime[numpts - 1]);
  1511.  
  1512. (* Now perform the back-substitution from the bottom up *)
  1513.   tempxys[numpts,1] := round (Xrprime[numpts]);
  1514.   tempxys[numpts,2] := round (Yrprime[numpts]);
  1515.   for i := numpts - 1 downto 1 do
  1516.     begin
  1517.     tempxys[i,1] := round (Xrprime[i] - beta[i] * tempxys[i + 1, 1]);
  1518.     tempxys[i,2] := round (Yrprime[i] - beta[i] * tempxys[i + 1, 2]);
  1519.     end;
  1520.  
  1521. if (isclosed) then
  1522.   begin
  1523.  (* at this point, we've probably been through one control-point
  1524.   *  adjustment, so let's not muck it up 
  1525.   *)
  1526.   tempxys[numpts+1,1] := tempxys[1,1];
  1527.   tempxys[numpts+1,2] := tempxys[1,2];
  1528.   tempxys[numpts+2,1] := tempxys[2,1];
  1529.   tempxys[numpts+2,2] := tempxys[2,2];
  1530.   tempxys[0,1] := tempxys[numpts,1];
  1531.   tempxys[0,2] := tempxys[numpts,2];
  1532.       (* copy them back *)
  1533.   for i := 0 to (numpts+2) do
  1534.     begin
  1535.     xys[i,1] := tempxys[i,1];
  1536.     xys[i,2] := tempxys[i,2];
  1537.     end;  
  1538.   end  (* closed *)
  1539. else
  1540.   begin
  1541.   (* copy back *)
  1542.   for i := 2 to numpts -1 do
  1543.    begin
  1544.     xys[i,1] := tempxys[i,1];
  1545.     xys[i,2] := tempxys[i,2];
  1546.    end;
  1547.   end;  (* open*)
  1548. end; 
  1549.                   
  1550.  
  1551. {-----------------------------------------------------}
  1552. (*  adjust the list of control points so that we can use
  1553.  *   it for  B-spline interpolation.  
  1554.  *  Add any "phantom" vertices necessary so that the end
  1555.  *   conditions will be correct for interpolation
  1556.  *)
  1557. procedure Bctlptadjust (isclosed : boolean; isarc : boolean;
  1558.              var n: integer; (* INOUT *)
  1559.                          var xys: ControlPoints; (* INOUT *)
  1560.                          var thx: ThickAryType); (* INOUT *)
  1561. var j : integer;
  1562.     tmp : ControlPoints;
  1563.     tmpthx : ThickAryType;
  1564. begin   (* ctlpt adjust*)
  1565.  
  1566. if (isclosed) then
  1567.   begin
  1568. (* here, we have to supply the last 'real' point for the user,
  1569.    and add three phantoms-- one before, and two after *)
  1570.  
  1571.   if (n = 2) then
  1572.     begin
  1573.     complain (ERRBAD);
  1574.     writeln(logfile,'A closed spline requires more than 2 control points ');
  1575.     writeln(logfile,'making a temporary fix in order to continue...');
  1576.     xys[3,1] := xys[1,1];
  1577.     xys[3,2] := xys[1,2];
  1578.     end;  
  1579.  
  1580.   for j := 1 to (n) do
  1581.     begin
  1582.     tmp[j, 1] := xys[j, 1];
  1583.     tmp[j, 2] := xys[j, 2];
  1584.     tmpthx[j] := thx[j];
  1585.     end;
  1586.         (* Now take care of the 'phantom' vertices *)    
  1587.   tmp[n+1, 1] := xys[1, 1];
  1588.   tmp[n+1, 2] := xys[1, 2];
  1589.   tmpthx[n+1] := thx[1];
  1590.   tmp[n+2, 1] := xys[2, 1];
  1591.   tmp[n+2, 2] := xys[2, 2];
  1592.   tmpthx[n+2] := thx[2];
  1593.   tmp[n+3, 1] := xys[3, 1]; 
  1594.   tmp[n+3, 2] := xys[3, 2];
  1595.   tmpthx[n+3] := thx[3];
  1596.  
  1597.   if (not isarc) then
  1598.     begin
  1599.     tmp[0,1] := xys[n, 1]; (* wrap around to the real last point *)
  1600.     tmp[0,2] := xys[n, 2];
  1601.     tmpthx[0] := thx[n];
  1602.     end
  1603.   else
  1604.     begin
  1605.     tmp[0,1] := xys[0,1];
  1606.     tmp[0,2] := xys[0,2];
  1607.     tmpthx[0] := thx[0];
  1608.     end;
  1609.  
  1610.   n := n + 1;     (* we supplied the 'last' point for the user *)
  1611.  
  1612.   for j := 0 to n+2 do
  1613.     begin
  1614.     xys[j,1] := tmp[j,1];
  1615.     xys[j,2] := tmp[j,2];
  1616.     thx[j] := tmpthx[j];
  1617.     end;  (* for *)
  1618.   end  (* if closed *)
  1619. else 
  1620.   begin         (* OPEN SPLINE *)
  1621.   if (not isarc) then
  1622.     begin
  1623.     tmp[0,1] := 2 * xys[1, 1] - xys[2,1];
  1624.     tmp[0,2] := 2 * xys[1, 2] - xys[2,2];
  1625.     end
  1626.   else
  1627.     begin
  1628.     tmp[0,1] := xys[0,1];
  1629.     tmp[0,2] := xys[0,2];
  1630.     end;
  1631.   tmpthx[0] := thx[1];
  1632.  
  1633.   for j := 1 to (n) do
  1634.     begin
  1635.     tmp[j, 1] := xys[j, 1];
  1636.     tmp[j, 2] := xys[j, 2];
  1637.     tmpthx[j] := thx[j];
  1638.     end;
  1639.   
  1640.   tmp[n+1, 1] := 2 * xys[n, 1] - xys[n-1,1];
  1641.   tmp[n+1, 2] := 2 * xys[n, 2] - xys[n-1,2];
  1642.   tmpthx[n+1] := thx[n];
  1643.  
  1644.   tmp[n+2, 1] := tmp[n+1, 1];
  1645.   tmp[n+2, 2] := tmp[n+1, 2];
  1646.   tmpthx[n+2] := thx[n];
  1647.  
  1648.   for j := 0 to n+2 do
  1649.     begin
  1650.     xys[j,1] := tmp[j,1];
  1651.     xys[j,2] := tmp[j,2];
  1652.     thx[j] := tmpthx[j];
  1653.     end;  (* for *)
  1654.   end; (*  if open *)
  1655.   
  1656. end;
  1657.  
  1658.  
  1659.  
  1660. {-----------------------------------------------------}
  1661. (*  adjust the list of control points so that we can use
  1662.  *       it for simple Catmull-Rom spline interpolation.  
  1663.  *  Add any "phantom" vertices necessary so that the end
  1664.  *   conditions will be correct for interpolation
  1665.  *)
  1666. procedure CRctlptadjust (isclosed : boolean; isarc : boolean;
  1667.              var n: integer; (* INOUT *)
  1668.                          var xys: ControlPoints; (* INOUT *)
  1669.                          var thx: ThickAryType); (* INOUT *)
  1670. var j : integer;
  1671.     tmp : ControlPoints;
  1672.     tmpthx : ThickAryType;
  1673. begin   (* ctlpt adjust*)
  1674. if (isclosed) then
  1675.   begin
  1676. (* here, we have to supply the last 'real' point for the user,
  1677.    and add three phantoms-- one before, and two after *)
  1678.  
  1679.   if (n = 2) then
  1680.     begin
  1681.       complain (ERRBAD);
  1682.       writeln(logfile,'A closed spline requires more than 2 control points ');
  1683.       writeln(logfile,'making a temporary fix in order to continue...');
  1684.       xys[3,1] := xys[1,1];
  1685.       xys[3,2] := xys[1,2];
  1686.     end;  
  1687.  
  1688.  
  1689.   for j := 1 to (n) do
  1690.     begin
  1691.     tmp[j, 1] := xys[j, 1];
  1692.     tmp[j, 2] := xys[j, 2];
  1693.     tmpthx[j] := thx[j];
  1694.     end;
  1695.             (* the phantom vertices *)    
  1696.     tmp[n+1, 1] := xys[1, 1];
  1697.     tmp[n+1, 2] := xys[1, 2];
  1698.     tmpthx[n+1] := thx[1];
  1699.     tmp[n+2, 1] := xys[2, 1];
  1700.     tmp[n+2, 2] := xys[2, 2];
  1701.     tmpthx[n+2] := thx[2];
  1702.     tmp[n+3, 1] := xys[3, 1];
  1703.     tmp[n+3, 2] := xys[3, 2];
  1704.     tmpthx[n+3] := thx[3];
  1705.   
  1706.     if (not isarc) then
  1707.       begin
  1708.       tmp[0,1] := xys[n, 1]; (* wrap around to the real last point *)
  1709.       tmp[0,2] := xys[n, 2];
  1710.       tmpthx[0] := thx[n];
  1711.       end
  1712.     else
  1713.       begin
  1714.       tmp[0,1] := xys[0,1];
  1715.       tmp[0,2] := xys[0,2];
  1716.       tmpthx[0] := thx[0];
  1717.       end;
  1718.     n := n + 1; (* we supplied the 'last' point for the user *)
  1719.   
  1720.     for j := 0 to n+2 do
  1721.       begin
  1722.       xys[j,1] := tmp[j,1];
  1723.       xys[j,2] := tmp[j,2];
  1724.       thx[j] := tmpthx[j];
  1725.       end;  (* for *)
  1726.   end  (* if closed *)
  1727. else
  1728.   begin (* OPEN SPLINE *)
  1729.   if (not isarc) then
  1730.     begin
  1731.     tmp[0,1] := xys[1, 1]; (* double the first point *)
  1732.     tmp[0,2] := xys[1, 2];
  1733.     end
  1734.   else
  1735.     begin
  1736.     tmp[0,1] := xys[0,1];
  1737.     tmp[0,2] := xys[0,2];
  1738.     end;  
  1739.   tmpthx[0] := thx[1];
  1740.  
  1741.   for j := 1 to (n) do
  1742.     begin
  1743.     tmp[j, 1] := xys[j, 1];
  1744.     tmp[j, 2] := xys[j, 2];
  1745.     tmpthx[j] := thx[j];
  1746.     end;
  1747.     
  1748.   tmp[n+1, 1] := xys[n, 1]; (* and triple the last *)
  1749.   tmp[n+1, 2] := xys[n, 2];
  1750.   tmpthx[n+1] := thx[n];
  1751.   tmp[n+2, 1] := xys[n, 1];
  1752.   tmp[n+2, 2] := xys[n, 2];
  1753.   tmpthx[n+2] := thx[n];
  1754.  
  1755.   for j := 0 to n+2 do
  1756.     begin
  1757.     xys[j,1] := tmp[j,1];
  1758.     xys[j,2] := tmp[j,2];
  1759.     thx[j] := tmpthx[j];
  1760.     end;  (* for *)
  1761.   end; (* if open *)
  1762. end;    (* ctlpt adjust *)
  1763.  
  1764.      
  1765.  
  1766. {----------------------------------------------------------}
  1767.  
  1768. procedure interpsplines (splinetype: SplineKind;
  1769.              isclosed: boolean;
  1770.              isanArc: boolean;
  1771.              linepatt : LineStyle;
  1772.                          var basismatrix : Fourby4Matrix; (* IN *)
  1773.                          numctls: integer; 
  1774.                          var arrayXY: ControlPoints; (* IN *)
  1775.                          var pointmatrix: SplineSegments; (* OUT *)
  1776.                          varythicks: boolean;
  1777.                          var thickmatrix: ThickAryType; (* IN *)
  1778.                          var TTmatrix: ThickAryType); (* OUT *)
  1779. label 32;
  1780. var xctl, yctl,        { vectors of x, y posits of control points}
  1781.     wctl : Oneby4Vector; {vector of thicknesses at each ctl pt}
  1782.     t, incr: real;
  1783.     Pi: integer;    { P sub i }
  1784.     i, currpt : integer;    
  1785.     theresolution : ScaledPts;
  1786.  
  1787. begin (* interp splines*)
  1788.   if ((not isclosed) and (isanArc)) then
  1789.     numctls := numctls + 1; (* lie a little *)
  1790.  
  1791.    case (splinetype) of
  1792.  
  1793.      BSPL: Bctlptadjust (isclosed, isanArc, numctls, arrayXY, thickmatrix);
  1794.      
  1795.      CARD,
  1796.      CATROM:  CRctlptadjust (isclosed, isanArc, numctls, arrayXY, thickmatrix);
  1797.     
  1798.      INTBSPL: begin
  1799.              if (isclosed) then
  1800.           begin
  1801.           Bctlptadjust (true, isanArc, numctls, arrayXY, thickmatrix);
  1802.           invertsplvertices (numctls, true, arrayXY);
  1803.           end
  1804.         else 
  1805.           begin
  1806.           invertsplvertices (numctls, false, arrayXY);
  1807.           Bctlptadjust (false, isanArc, numctls, arrayXY, thickmatrix);
  1808.           end;  (* else *)
  1809.                end; (* Interpolating Bsplines *)
  1810.    end;
  1811.  
  1812.   if ((not isclosed) and (isanArc)) then
  1813.     numctls := numctls - 1; (* UN-lie a little *)
  1814.  
  1815.  
  1816. (* this is the scheme:
  1817.  *    val :=  t-vector   *  Basis matrix     * point matrix
  1818.  *        [t^3  t^2 t 1] *      [[Ms]]       * [Pi-1 Pi Pi+1 Pi+2]
  1819.  *    where "Pi-1" is "P sub (i-1)", etc.
  1820.  *
  1821.  *  But we do this in a round about way:
  1822.  *        Point matrix * basis
  1823.  *   then   * t-vector   will yield the single value
  1824.  *   
  1825.  *   there are certainly faster ways to do this, 
  1826.  *   but this is the easiest to understand
  1827.  *)
  1828.  
  1829.   currpt := 1;
  1830.   case linepatt of
  1831.      solid : theresolution := MAXVECLENsp;
  1832.      dotted,
  1833.      dashed,
  1834.      dotdash : theresolution := 3 * MAXVECLENsp; {###}
  1835.    end;
  1836.  
  1837.   for Pi := 1 to (numctls - 1) do
  1838.     begin
  1839.     xctl[1] := float(arrayXY[Pi-1, 1]);
  1840.     xctl[2] := float(arrayXY[Pi,   1]);
  1841.     xctl[3] := float(arrayXY[Pi+1, 1]);
  1842.     xctl[4] := float(arrayXY[Pi+2, 1]);
  1843.     yctl[1] := float(arrayXY[Pi-1, 2]);
  1844.     yctl[2] := float(arrayXY[Pi,   2]);
  1845.     yctl[3] := float(arrayXY[Pi+1, 2]);
  1846.     yctl[4] := float(arrayXY[Pi+2, 2]);
  1847.     matXvector (basismatrix, xctl, xctl);
  1848.     matXvector (basismatrix, yctl, yctl);
  1849.  
  1850.     (* compute the delta-t increment for this segment
  1851.         based on a metric for subdivision *)
  1852.     intervals := numsubdivisions (xctl, yctl, theresolution);
  1853.     if ((linepatt = solid) and (intervals <= 2)) then
  1854.       intervals := intervals * 2;
  1855.     incr := 1.0 / intervals;
  1856.  
  1857.     (* avoid over-flowing the "pointmatrix" *)
  1858.     if ((currpt + intervals - 1) >= MAXSPLINESEGS) then
  1859.        begin
  1860.        complain (ERRREALBAD);
  1861.        writeln (logfile,'error: Too many spline segments required.');
  1862.        writeln (logfile,' Reducing the number of control points to get output.');
  1863.        goto 32;
  1864.        end;
  1865.   
  1866.     t := 0.0;
  1867.     while (t < 0.999999999) do
  1868.       begin
  1869.     pointmatrix[currpt, 1] := round (splinePosition (xctl, t));
  1870.     pointmatrix[currpt, 2] := round (splinePosition (yctl, t));
  1871.  
  1872.     if (varythicks) then
  1873.       begin
  1874.         wctl[1] := float(thickmatrix[Pi-1]);
  1875.         wctl[2] := float(thickmatrix[Pi  ]);
  1876.         wctl[3] := float(thickmatrix[Pi+1]);
  1877.         wctl[4] := float(thickmatrix[Pi+2]);
  1878.         matXvector (catrommtx, wctl, wctl);  (* requires using Catmull-Rom *)
  1879.         TTmatrix[currpt] := round (splinePosition (wctl, t));
  1880.       end;
  1881.     
  1882.         t := t + incr;
  1883.         currpt := currpt + 1;
  1884.       end; (* while loop *)
  1885.  
  1886.  
  1887.     end; (* for loop *)
  1888.  
  1889. 32:
  1890.     (* the END-condtion *)
  1891.     pointmatrix[currpt, 1] := round (splinePosition (xctl, 1.0));
  1892.     pointmatrix[currpt, 2] := round (splinePosition (yctl, 1.0));    
  1893.     if (varythicks) then
  1894.       begin
  1895.     wctl[1] := thickmatrix[numctls-2];
  1896.     wctl[2] := thickmatrix[numctls-1];
  1897.     wctl[3] := thickmatrix[numctls];
  1898.     wctl[4] := thickmatrix[numctls+1];
  1899.     matXvector (catrommtx, wctl, wctl);  (* requires using Catmull-Rom *)
  1900.     TTmatrix[currpt] := round (splinePosition (wctl, 1.0));
  1901.       end;
  1902.  
  1903.     lastPoint := currpt;
  1904.  
  1905. end; (* interpsplines *)
  1906.  
  1907.  
  1908. {----------------------------------------------------------------}
  1909. procedure drawSpline (splinetype : SplineKind;
  1910.              isclosed: boolean;
  1911.              isanArc: boolean;
  1912.              patt : LineStyle;
  1913.                      numctls: integer;
  1914.                      var arrayXY: ControlPoints; (* IN *)
  1915.                      var pointmatrix: SplineSegments; (* OUT *)
  1916.                      varythicks: boolean;
  1917.                      var thickmatrix: ThickAryType; (* IN *)
  1918.                      var TTmatrix: ThickAryType); (* OUT *)
  1919. begin
  1920.   lastPoint := 0;
  1921.  
  1922.  
  1923.   case (splinetype) of
  1924.     CATROM : interpsplines (splinetype, isclosed, isanArc, patt, catrommtx,
  1925.                numctls, arrayXY, pointmatrix,
  1926.                          varythicks, thickmatrix, TTmatrix);
  1927.  
  1928.     CARD : interpsplines (splinetype, isclosed, isanArc, patt, cardmtx, 
  1929.                numctls, arrayXY, pointmatrix, 
  1930.                        varythicks, thickmatrix, TTmatrix);
  1931.  
  1932.     BSPL : interpsplines (splinetype, isclosed, isanArc, patt, bsplmtx, 
  1933.                numctls, arrayXY, pointmatrix, 
  1934.                        varythicks, thickmatrix, TTmatrix);
  1935.  
  1936.     INTBSPL : interpsplines (splinetype, isclosed, isanArc, patt, bsplmtx,
  1937.                numctls, arrayXY, pointmatrix, 
  1938.                        varythicks, thickmatrix, TTmatrix);
  1939.   end; (*Case *)                   
  1940. end;
  1941.  
  1942.  
  1943. (* &&module TeXtyl *)
  1944. {----------------------------------------------------------------}
  1945. (* rotate a (x,y) point about mx, my *)
  1946. procedure ptrotate (var x, y : integer;
  1947.                         mx, my: integer;
  1948.                         angle : real);
  1949. var tmpx, tmpy : integer;
  1950.     cosa, sina : real;
  1951. begin
  1952.   tmpx := x - mx;       
  1953.   tmpy := y - my;
  1954.   cosa := cos(angle * DEGTORAD); 
  1955.   sina := sin(angle * DEGTORAD);
  1956.   x := round(tmpx * cosa - tmpy * sina) + mx;
  1957.   y := round(tmpx * sina + tmpy * cosa) + my;
  1958. end;
  1959.  
  1960. {----------------------------------------------------------------}
  1961. (* transform two line points: scale, rotate and translate 
  1962. *)
  1963. procedure xfmlinepts (var x1, y1, x2, y2 : ScaledPts;
  1964.                         offh, offv : ScaledPts;
  1965.                         midx, midy : ScaledPts;
  1966.                         scalefact : real;
  1967.                         theta : real;
  1968.                         dx, dy : ScaledPts;
  1969.                         sx, sy : real);
  1970. begin
  1971.   if ((sx = 0.0) or (sy = 0.0)) then
  1972.     begin
  1973.       complain (ERRBAD);
  1974.       writeln(logfile,'?? Some scale factor is Zero... continuing anyway');
  1975.     end;
  1976.         (* scale about center of item*)
  1977.   if ((sx <> 1.0) or (sy <> 1.0)) then
  1978.    begin
  1979.    x1 := round((x1 - midx) * sx) + midx;
  1980.    x2 := round((x2 - midx) * sx) + midx;
  1981.    y1 := round((y1 - midy) * sy) + midy;     
  1982.    y2 := round((y2 - midy) * sy) + midy;
  1983.    end;
  1984.       (* rotate if necessary *)
  1985.    if (theta <> 0.0) then
  1986.      begin  (* rotate about the midpoint *)
  1987.      ptrotate(x1, y1, midx, midy, theta);
  1988.      ptrotate(x2, y2, midx, midy, theta);
  1989.      end;
  1990.       (* translate *)
  1991.    x1 := (x1 + round(dx * scalefact) + offh);
  1992.    x2 := (x2 + round(dx * scalefact) + offh);
  1993.    y1 := (y1 + round(dy * scalefact) + offv);
  1994.    y2 := (y2 + round(dy * scalefact) + offv);
  1995. end;  (* xfmlinepts *)
  1996.  
  1997. {----------------------------------------------------------------}
  1998. procedure xfmcontpts (var xpts : ControlPoints; xknots : integer;
  1999.                         offh, offv : ScaledPts; midx, midy : ScaledPts;
  2000.                         scalefact : real;
  2001.                         theta : real; dx, dy : ScaledPts; sx, sy : real);
  2002. var i : integer;
  2003. begin
  2004.     (* scale about center of item *)
  2005.  if ((sx <> 1.0) or (sy <> 1.0)) then
  2006.   for i := 0 to xknots do
  2007.      begin
  2008.      xpts[i,1] := round((xpts[i,1] - midx) * sx) + midx;
  2009.      xpts[i,2] := round((xpts[i,2] - midy) * sy) + midy;
  2010.      end;
  2011.  
  2012.   if (theta <> 0.0) then
  2013.     begin (* rotate about center *)
  2014.     for i := 0 to xknots do
  2015.       begin
  2016.       ptrotate (xpts[i,1], xpts[i,2], midx, midy, theta);
  2017.       end;
  2018.     end;
  2019.     (* translate *)
  2020.   for i := 0 to xknots do
  2021.     begin
  2022.     xpts[i,1] := (xpts[i,1] + round(dx * scalefact) + offh);
  2023.     xpts[i,2] := (xpts[i,2] + round(dy * scalefact) + offv);
  2024.     end;
  2025. end;  (* xfmcontpts *)
  2026.  
  2027.  
  2028. {----------------------------------------------------------------}
  2029. (* convert into DVI space and offset by H & V *)
  2030. procedure dvilinepts (var x1, y1, x2, y2 : ScaledPts;
  2031.             offh, offv : ScaledPts);
  2032. begin
  2033.    x1 := (x1  + offh);
  2034.    x2 := (x2  + offh);
  2035.    y1 := (y1 * (-1) + offv);
  2036.    y2 := (y2 * (-1) + offv);
  2037. end;
  2038.  
  2039. {----------------------------------------------------------------}
  2040. (* convert into DVI space and offset by H & V *)
  2041. procedure dvicontpts (var xpts : ControlPoints; xknots : integer;
  2042.                         offh, offv : ScaledPts);
  2043. var i : integer;
  2044. begin
  2045.   for i := 0 to xknots do
  2046.     begin
  2047.     xpts[i,1] := (xpts[i,1]  + offh);
  2048.     xpts[i,2] := (xpts[i,2] * (-1) + offv);
  2049.     end;
  2050. end;
  2051.  
  2052. {----------------------------------------------------------------}
  2053. (*    transform all the figure's elements according to the 
  2054.     top-level tranformation requirements in 1st Quadrant space.
  2055.     then reset the toplevel's xfms.
  2056. *)
  2057. procedure toplevelxfm (toplev, curfig : pItem; recurlevel : integer);
  2058. var pi : pItem;
  2059.     null1, null2 : ScaledPts;
  2060.     old1, old2 : ScaledPts;
  2061.     midx, midy : ScaledPts;
  2062. begin
  2063.   with toplev^ do
  2064.     begin
  2065.     midy := (BBty - BBby) div 2;
  2066.     midx := (BBrx - BBlx) div 2;
  2067.     end;
  2068.   pi := curfig^.body^.things;  { if recur==0, this is same as toplev }
  2069.   while (pi <> nil) do
  2070.     begin
  2071.     with pi^ do
  2072.       begin
  2073.       case (kind) of
  2074.     Aline : begin
  2075.         xfmlinepts (lx1, ly1, lx2, ly2, 0, 0, midx, midy, 1.0, 
  2076.               toplev^.figtheta, toplev^.fdx, toplev^.fdy,
  2077.               toplev^.fsx, toplev^.fsy);
  2078.         end;
  2079.     Aspline : begin
  2080.           xfmcontpts (spts, nsplknots, 0, 0, midx, midy, 1.0,
  2081.               toplev^.figtheta, toplev^.fdx, toplev^.fdy,
  2082.               toplev^.fsx, toplev^.fsy);
  2083.           end;
  2084.     Attspline : begin
  2085.           xfmcontpts (ttpts, nttknots, 0, 0, midx, midy, 1.0,
  2086.               toplev^.figtheta, toplev^.fdx, toplev^.fdy,
  2087.               toplev^.fsx, toplev^.fsy);
  2088.             end;
  2089.     Aarc : begin
  2090.            null1 := 0; null2 := 0;
  2091.            old1 := acentx; old2 := acenty;
  2092.            xfmlinepts (acentx, acenty, null1, null2, 0,0, midx, midy, 1.0,
  2093.             toplev^.figtheta, toplev^.fdx, toplev^.fdy,
  2094.             toplev^.fsx, toplev^.fsy);        
  2095.                   
  2096.            xfmcontpts (arcpts, narcknots + 1, 0, 0, old1, old2, 1.0,
  2097.               toplev^.figtheta, 
  2098.               toplev^.fdx + (acentx - old1), 
  2099.               toplev^.fdy + (acenty - old2),
  2100.               toplev^.fsx, toplev^.fsy);
  2101.            end;              
  2102.     Alabel : begin
  2103.          null1 := 0; null2 := 0;
  2104.          xfmlinepts (labx, laby, null1, null2, 0, 0, midx, midy, 1.0,
  2105.               toplev^.figtheta, toplev^.fdx, toplev^.fdy,
  2106.               toplev^.fsx, toplev^.fsy);        
  2107.          end;
  2108.     Abeam : ;   (* not transformable *)
  2109.  
  2110.     Atieslur: ; (* not transformable *)
  2111.  
  2112.     Afigure : begin
  2113.             toplevelxfm (toplev, pi, recurlevel + 1);
  2114.           end;
  2115.       end; (* case *)
  2116.     end; (* with *)
  2117.     pi := pi^.nextitem;
  2118.     end;  (* while *)
  2119.   if (recurlevel = 0) then
  2120.     begin (* reset the toplevel's xfms *)
  2121.     with toplev^ do
  2122.       begin
  2123.       figtheta := 0.0;
  2124.       fsx := 1.0; fsy := 1.0;
  2125.       fdx := 0;   fdy := 0;
  2126.       end;    
  2127.     end;
  2128. end;
  2129.  
  2130.  
  2131. {----------------------------------------------------------------}
  2132. function scalefitfactor (actualwid, actualht, 
  2133.              goalwid, goalht: ScaledPts): real;
  2134. var sx, sy : real;
  2135. begin
  2136.   sx := goalwid/actualwid;
  2137.   sy := goalht/actualht;
  2138.   if (sx < sy) then
  2139.     scalefitfactor := sx
  2140.   else
  2141.     scalefitfactor := sy;
  2142. end;  
  2143.  
  2144.  
  2145.  
  2146. (* ---- The handlers for each primitive ---- 
  2147.  *   The result of calling each handler is either immediate
  2148.  *       output to the buffer of the commands to produce the
  2149.  *       primitive, OR the primitive gets pushed onto a stack/list
  2150.  *       that defines a current 'figure' (set of prims) for
  2151.  *       output at a later time
  2152.  *
  2153.  *  Look at linehandle for a basic idea of how the handlers
  2154.  *  work. the others follow pretty closely.
  2155.  *)
  2156.  
  2157.  
  2158. {------------------------------------------------------------}
  2159. procedure linehandle (figdepth : integer; scalefact: real; 
  2160.                      x1, y1, x2, y2 : ScaledPts;
  2161.                      dvih, dviv : ScaledPts; (* possible dvi-offsets *)
  2162.                      thk : VThickness; vk : VectKind;
  2163.              patt : LineStyle;
  2164.              minx, maxx, miny, maxy : ScaledPts;
  2165.                      tx, ty: ScaledPts; sx, sy, r : real);
  2166. var midx, midy : ScaledPts;                  
  2167.     lineitem : pItem;
  2168. begin
  2169.    midx := (minx + maxx) div 2;
  2170.    midy := (miny + maxy) div 2;
  2171.  
  2172.     (* do local primitive -level transformations *)
  2173.    xfmlinepts (x1, y1, x2, y2, dvih, dviv,
  2174.                 midx, midy, scalefact, r, tx, ty, sx, sy);
  2175.  
  2176. E_O_F
  2177. else
  2178.   echo "will not over write ./src/textyl.pas.ad"
  2179. fi
  2180. chmod 644 ./src/textyl.pas.ad
  2181. if [ `wc -c ./src/textyl.pas.ad | awk '{printf $1}'` -ne 30107 ]
  2182. then
  2183. echo `wc -c ./src/textyl.pas.ad | awk '{print "Got " $1 ", Expected " 30107}'`
  2184. fi
  2185. echo "Finished archive 6 of 9"
  2186. exit
  2187.